perm filename QSPEXP.F4[MUS,LCS] blob
sn#107317 filedate 1974-06-16 generic text, type T, neo UTF8
00100 SUBROUTINE SPEED(Q)
00200 COMMON/RD/TM(50),SP1(50),SP2(50),SFAC(512)/XX/F(5,512)
00300 COMMON XS(100),YS(100),N,X1(512),Y1(512),S(100),K
00400 DIMENSION X2(512),Y2(512)
00500 EQUIVALENCE (X2,F(1,1)),(Y2,F(1,256))
13200 24 FORMAT(' SET TOTAL TIME='$)
13300 TYPE 24
13400 ACCEPT 30,TIME
13500 IF(TIME)GO TO 12
13550 TX=0
13600 AB=.3
13700 NSP=1
13800 CC GO TO 254
13900 250 TYPE 25
13910 30 FORMAT(3F)
14000 25 FORMAT(' TIME, SPD1, SPD2 -- '$)
14100 ACCEPT 30,AB,SP1(NSP),SP2(NSP)
14200 IF(AB.EQ.-99)GO TO 12
14300 IF(AB)GO TO 251
14305 TX=TX+AB
14315 254 J=TX/TIME*512.
14320 IF(J.EQ.0)J=1
14500 CC NX=X1(J)*10.
14600 CC NY=Y1(J)*10.
14700 CC CALL SETCUR(NX,NY,0)
14800 TM(NSP)=AB
14900 IF(TX.GE.TIME)GO TO 253
15000 NSP=NSP+1
15100 GO TO 250
15200 251 NSP=NSP-1
15300 IF(NSP.LE.0)NSP=1
15400 AB=TM(NSP)
15500 TYPE 30,AB,SP1(NSP)
15600 GO TO 254
15700 253 TM(NSP+1)=0
15850
16100 SP=0
16200 DO 1 K=1,50
16300 IF(TM(K).EQ.0)GO TO 10
16400 SP=SP+TM(K)*(SP1(K)+SP2(K))/2.
16500 1 TM(K)=512.*TM(K)/TIME
16600 C SETS SPEED FACTORS - AND TIME IN TERMS OF 512 UNITS.
16700 10 SP=TIME/SP
16710 K=0
16720 N=0
16740 H=1-SP
16800 2 G=0
17000 N=N+1
17005 C RESETS FOR NEXT TIME UNIT
17100 DIF=SP2(N)-SP1(N)
17200 C TOTAL SPEED CHANGE
17300 11 K=K+1
17400 G=G+1
17500 H=H+SP*(G/TM(N)*DIF+SP1(N))
17600 SFAC(K)=H+.00001
17605 C WILL IT END UP ON 512??????
17610 IF(K.EQ.512)GO TO 12
17700 IF(G.GE.TM(N))GO TO 2
17800 GO TO 11
17900 C TD=TOTAL DISTANCE OF PATH
18000 12 DO 3 K=1,511
18100 J=K+1
18200 Q=SFAC(K)
18300 L=Q
18400 CC R=SFAC(J)
18500 CC M=R
18600 A=X1(L)
18700 B=X1(L+1)
18800 CC C=R-L
18900 D=B-A
19000 C DIF IN DISTS.
19010 E=Q-L
19100 X2(K)=A+D*E
19300 A=Y1(L)
19310 B=Y1(L+1)
19320 D=B-A
19400 3 Y2(K)=A+D*E
19410 DO 4 K=1,511
19420 X1(K)=X2(K)
19430 4 Y1(K)=Y2(K)
40000 END